unit GraphObjects;
(*
  Graphical objects and modification routines as part of Voronoi algorithm
  of Christian Huettig Copyright (C) 2002
  Restrictions: None
*)
interface

uses
  System.Types,
  System.SysUtils,
  System.Classes,
  System.Math,
  Vcl.Dialogs,
  Vcl.Forms,
  Vcl.Graphics;

type
  TRGB = packed record // Variant record to mix colors fast
    case boolean of
      True:
        (Color: LongWord); // 32bit Color value (like TColor)
      False:
        (R, G, B, A: Byte); // 8bit RGBA split, alpha isn't used
  end;
  TGLineState = (TwoPoint, OnePoint, Vector);
  // |------|, |----->, <---|------|----> (Vector isn't the right name, its an endless line in both directions marked through two point)

  // Graphical Objects
  TGraphObject = class // Base object for all drawable elements + management
  private
    orig_index: integer;
    // Index of list at create time (movetolist and clonetolist don't change this index, only set on create
    index: integer; // Index of current list
    List: TList;
    // Current list, can only be changed through movetolist or clonetolist
    Canvas: TCanvas;
  protected
    constructor Create(L: TList; C: TCanvas);
  public
    Color: TRGB;
    aColor: TColor; // not Used
    procedure MoveToList(L: TList);
    procedure CopyToList(L: TList);
    // same as move, but now the object is on more than one list. careful, because index is left on old list !
    function CloneToList(L: TList): TGraphObject;
    // Creates a new object and moves it to L
    function GetIndex: integer;
    function GetOrigIndex: integer;
    // returns the index of the list were it was created
    procedure Delete(orig: boolean);
    // orig=true means that the object is in its "original" list. now reindexes also orig_index
    procedure SetCanvas(C: TCanvas);
    function GetCanvas: TCanvas;
    procedure ReIndex(orig: boolean); overload;
    // slow reindex by searching the list for "self"
    procedure ReIndex(orig: boolean; i: integer); overload;
    // fast reindex with validation
    procedure Draw; virtual; abstract;
    procedure Clear; virtual; abstract;
    function Clone: TGraphObject; virtual; abstract;
  end;

  TGPoint = class; // forward declaration

  TGLine = class(TGraphObject)
  private
    state: TGLineState; // see above
    d, dx, dy: extended; // d=distance, dx,dy=delta
    ix, iy, t, R: extended;
    // ex,ey=unity vector, ix,iy=crosspoint(set after Intersect), t,r=distances to ipoint
    procedure initialize; // evaluates all constants if line has changed
  public
    p1, p2: TGPoint;
    ex, ey: extended; // Unity vector of the line
    BisectorOf: array [1 .. 2] of integer;
    // The orig_index of the points from which this line is the bisector. -1 if none
    constructor Create(p1_, p2_: TGPoint; s: TGLineState; L: TList; C: TCanvas);
    function Clone: TGraphObject; override;
    procedure Draw; override;
    procedure Clear; override;
    function GetState: TGLineState;
    function Intersect(ln: TGLine): boolean;
    procedure GetCurrentIPoint(var x, y: extended); overload;
    // copies ix and iy. only valid after intersect() call !
    procedure GetCurrentIPoint(var p: TGPoint); overload;
    // copies ix and iy to a point. only valid after intersect() call !
    procedure CutRight(ln: TGLine); // Cuts the line right on ln
    procedure CutLeft(ln: TGLine);
    procedure CutBoth(ln: TGLine);
  end;

  TGPoint = class(TGraphObject)
  private
    x, y: extended;
  public
    closeDist: extended;
    // distance to point for MatchPoint=true (0=exact match)
    constructor Create(x_, y_: extended; L: TList; C: TCanvas);
    function Clone: TGraphObject; override;
    procedure Draw; override;
    procedure Clear; override;
    function getX: extended;
    function getY: extended;
    function DistanceTo(p: TGPoint): extended; overload;
    function DistanceTo(x_, y_: extended): extended; overload;
    procedure MoveTo(x_, y_: extended);
    function Match(p: TGPoint): boolean; overload;
    function Match(x_, y_: extended): boolean; overload;
    function Angle(p: TGPoint): extended;
    // required for the convex hull (preparata-hong)
    function IsRightTurn(p1, p2: TGPoint): boolean;
    // required for Graham scan (discarded, but left for further use)
    function areCollinear(A, B: TGPoint): boolean;
    function Bisector(p: TGPoint): TGLine;
    // Creates a line and sets BisectorOf[1..2]
    function CircleCenter(A, B: TGPoint): TGPoint; // never used
  end;

//==================================================
implementation
//==================================================

uses
  Vor2dPickFm;


//========================= TGraphObject =========================

constructor TGraphObject.Create(L: TList; C: TCanvas);
begin
  List := L;
  if List <> nil then
    index := L.Add(self);
  orig_index := index;
  Canvas := C;
end;

procedure TGraphObject.MoveToList(L: TList);
begin
  if List <> nil then
    List.items[index] := nil;
  index := L.Add(self);
  List := L;
end;

procedure TGraphObject.CopyToList(L: TList);
begin
  L.Add(self);
end;

function TGraphObject.CloneToList(L: TList): TGraphObject;
begin
  result := Clone;
  result.MoveToList(L);
end;

procedure TGraphObject.Delete;
var
  z: integer;
begin
  if List <> nil then
  begin
    List.Delete(index);
    List.pack;
    for z := 0 to List.count - 1 do
      TGraphObject(List.items[z]).ReIndex(orig);
  end;
  free;
end;

procedure TGraphObject.ReIndex(orig: boolean);
// slow reindex by searching List for "self"
begin
  index := List.IndexOf(self);
  if index < 0 then
    raise ERangeError.Create
      ('An object lost its bounding to a list ! (ReIndex call failed)');
  if orig then
    orig_index := index;
end;

procedure TGraphObject.ReIndex(orig: boolean; i: integer);
// fast reindex with validation
begin
  if List.items[i] <> self then
    raise ERangeError.Create
      ('An object lost its bounding to a list ! (ReIndex call failed)');
  index := i;
  if orig then
    orig_index := index;
end;

function TGraphObject.GetIndex: integer;
begin
  result := index;
end;

function TGraphObject.GetOrigIndex: integer;
begin
  result := orig_index;
end;

procedure TGraphObject.SetCanvas(C: TCanvas);
begin
  Canvas := C;
end;

function TGraphObject.GetCanvas: TCanvas;
begin
  result := Canvas;
end;

// ================== TGLine =======================

procedure TGLine.initialize;
begin
  dx := p2.getX - p1.getX;
  dy := p2.getY - p1.getY;
  d := sqrt(dx * dx + dy * dy);
  // m:=dy/dx;
  ex := dx / d;
  ey := dy / d;
end;

constructor TGLine.Create(p1_, p2_: TGPoint; s: TGLineState; L: TList;
  C: TCanvas);
begin
  p1 := p1_;
  p2 := p2_;
  BisectorOf[1] := -1;
  BisectorOf[2] := -1;

  state := s;
  inherited Create(L, C);
  Color.Color := $00FFFFFF;
  initialize;
end;

function TGLine.Clone: TGraphObject;
begin
  result := TGLine.Create(p1, p2, state, nil, GetCanvas);
  result.orig_index := GetOrigIndex;
  TGLine(result).BisectorOf[1] := BisectorOf[1];
  TGLine(result).BisectorOf[2] := BisectorOf[2];
end;

procedure TGLine.Draw;
var
  maxl: extended; // maximal line length possible in canvas, let canvas clip.
  p: TPoint; // needed to set locations in canvas
begin
  maxl := sqrt(sqr(GetCanvas.ClipRect.Right) + sqr(GetCanvas.ClipRect.Bottom));
  GetCanvas.Pen.Color := Color.Color;
  case state of
    TwoPoint:
      begin
        p.x := round(p1.getX);
        p.y := round(p1.getY);
        GetCanvas.PenPos := p;
        GetCanvas.LineTo(round(p2.getX), round(p2.getY));
      end;
    OnePoint:
      begin
        p.x := round(p1.getX);
        p.y := round(p1.getY);
        GetCanvas.PenPos := p;
        GetCanvas.LineTo(round(p1.getX + maxl * 2 * ex),
          round(p1.getY + maxl * 2 * ey));
      end;
    Vector:
      begin
        p.x := round(p1.getX - maxl * ex);
        p.y := round(p1.getY - maxl * ey);
        GetCanvas.PenPos := p;
        GetCanvas.LineTo(round(p1.getX + maxl * 2 * ex),
          round(p1.getY + maxl * 2 * ey));
      end;
  end;
end;

procedure TGLine.Clear;
begin
end;

function TGLine.GetState: TGLineState;
begin
  result := state;
end;

function TGLine.Intersect(ln: TGLine): boolean;
var
  ax, ay, divider: extended;
begin
  result := false;
  divider := ex * ln.ey - ey * ln.ex;
  if divider = 0 then
    exit; // paralell
  R := -(p1.getX * ey - p1.getY * ex + ex * ln.p1.getY - ey * ln.p1.getX)
    / divider;
  t := -(p1.getX * ln.ey - p1.getY * ln.ex - ln.p1.getX * ln.ey + ln.p1.getY *
    ln.ex) / divider;
  ax := p1.getX + t * ex;
  ay := p1.getY + t * ey;
  if (state = Vector) and (ln.state = Vector) then
    result := true;
  if (state = Vector) and (ln.state = OnePoint) then
    if R >= 0 then
      result := true;
  if (state = Vector) and (ln.state = TwoPoint) then
    if (R >= 0) and (R <= ln.d) then
      result := true;
  if (state = OnePoint) and (ln.state = Vector) then
    if (t >= 0) then
      result := true;
  if (state = OnePoint) and (ln.state = OnePoint) then
    if (t >= 0) and (R >= 0) then
      result := true;
  if (state = OnePoint) and (ln.state = TwoPoint) then
    if (t >= 0) and (R >= 0) and (R <= ln.d) then
      result := true;
  if (state = TwoPoint) and (ln.state = Vector) then
    if (t >= 0) and (t <= d) then
      result := true;
  if (state = TwoPoint) and (ln.state = OnePoint) then
    if (t >= 0) and (t <= d) and (R >= 0) then
      result := true;
  if (state = TwoPoint) and (ln.state = TwoPoint) then
    if (t >= 0) and (t <= d) and (R >= 0) and (R <= ln.d) then
      result := true;
  if result then
  begin
    ix := ax;
    iy := ay;
  end;
end;

procedure TGLine.GetCurrentIPoint(var x, y: extended);
// copies ix and iy. only valid after intersect() call !
begin
  x := ix;
  y := iy;
end;

procedure TGLine.GetCurrentIPoint(var p: TGPoint);
// copies ix and iy. only valid after intersect() call !
begin
  if assigned(p) then
    p.free;
  p := TGPoint.Create(ix, iy, nil, GetCanvas);
end;

procedure TGLine.CutRight(ln: TGLine);
begin
  if Intersect(ln) then
  begin
    if state = Vector then
    begin
      state := OnePoint;
      p1.MoveTo(ix, iy);
      if ex > 0 then
      begin
        ex := -ex;
        ey := -ey;
      end;
      p2.MoveTo(ix + ex, iy + ey);
    end
    else

      if state = OnePoint then
    begin
      if ex > 0 then
      begin
        state := TwoPoint;
        p2.MoveTo(ix, iy);
      end
      else
      begin
        // state unchanged ! stais OnePoint !!!
        p1.MoveTo(ix, iy);
        p2.MoveTo(ix + ex, iy + ey);
      end;
    end
    else

      if state = TwoPoint then
    begin
      state := TwoPoint;
      if ex > 0 then
      begin
        p2.MoveTo(ix, iy);
      end
      else
      begin
        p1.MoveTo(ix, iy);
      end;
    end;
    initialize;
  end;
end;

procedure TGLine.CutLeft(ln: TGLine);
begin
  if Intersect(ln) then
  begin
    if state = Vector then
    begin
      state := OnePoint;
      p1.MoveTo(ix, iy);
      if ex <= 0 then
      begin
        ex := -ex;
        ey := -ey;
      end;
      p2.MoveTo(ix + ex, iy + ey);
    end
    else if state = OnePoint then
    begin
      if ex <= 0 then
      begin
        state := TwoPoint;
        p2.MoveTo(ix, iy);
      end
      else
      begin
        // state unchanged ! stais OnePoint !!!
        p1.MoveTo(ix, iy);
        p2.MoveTo(ix + ex, iy + ey);
      end;
    end
    else if state = TwoPoint then
    begin
      if ex <= 0 then
      begin
        p2.MoveTo(ix, iy);
      end
      else
      begin
        p1.MoveTo(ix, iy);
      end;
    end;
    initialize;
  end;
end;

procedure TGLine.CutBoth(ln: TGLine); // caller line must be the one on top
var
  A, B: TGLine;
begin
  A := (Clone as TGLine);
  B := (ln.Clone as TGLine);
  if A.ey > 0 then
  begin
    A.ex := -A.ex;
    A.ey := -A.ey;
  end;

  if B.ey > 0 then
  begin
    B.ex := -B.ex;
    B.ey := -B.ey;
  end;

  if A.ex >= B.ex then
  begin
    if A.ex > 0 then
      CutRight(ln)
    else
      CutLeft(ln);
    if B.ex < 0 then
      ln.CutRight(A)
    else
      ln.CutLeft(A);
  end
  else
  begin
    if A.ex > 0 then
      CutRight(ln)
    else
      CutLeft(ln);
    if B.ex > 0 then
      ln.CutLeft(A)
    else
      ln.CutRight(A);
  end;
  A.free;
  B.free;
end;

// =========== TGPoint  ================================

constructor TGPoint.Create(x_, y_: extended; L: TList; C: TCanvas);
begin
  x := x_;
  y := y_;
  inherited Create(L, C);
  Color.Color := $00FFFFFF;
  closeDist := 2;
end;

// ------------------------------------------------------------------

function TGPoint.Clone: TGraphObject;
var
  A: TGPoint;
begin
  A := TGPoint.Create(x, y, nil, GetCanvas);
  A.orig_index := GetOrigIndex;
  result := A;
end;

procedure TGPoint.Draw;
begin
  GetCanvas.pixels[round(x), round(y)] := Color.Color;
end;

procedure TGPoint.Clear;
begin
end;

function TGPoint.getX: extended;
begin
  result := x;
end;

function TGPoint.getY: extended;
begin
  result := y;
end;

function TGPoint.DistanceTo(p: TGPoint): extended;
begin
  result := sqrt((p.x - x) * (p.x - x) + (p.y - y) * (p.y - y));
end;

function TGPoint.DistanceTo(x_, y_: extended): extended;
begin
  result := sqrt((x_ - x) * (x_ - x) + (y_ - y) * (y_ - y));
end;

procedure TGPoint.MoveTo(x_, y_: extended);
begin
  x := x_;
  y := y_;
end;

function TGPoint.Match(p: TGPoint): boolean;
begin
  result := (DistanceTo(p) <= closeDist);
end;

function TGPoint.Match(x_, y_: extended): boolean;
begin
  result := (DistanceTo(x_, y_) <= closeDist);
end;

function TGPoint.Angle(p: TGPoint): extended;
// required for building the convex hull
begin
  result := arcsin((p.x - x) / DistanceTo(p));
  if (p.x >= x) and (p.y >= y) then
  else if (p.x >= x) and (p.y < y) then
    result := pi - result
  else if (p.x < x) and (p.y >= y) then
    result := (pi + pi) + result
  else if (p.x < x) and (p.y < y) then
    result := pi - result;

end;

function TGPoint.IsRightTurn(p1, p2: TGPoint): boolean;
// required for Graham scan
var
  a1, a2: extended;
begin
  a1 := Angle(p1);
  a2 := Angle(p2);
  a1 := a1 - a2;
  if a1 < 0 then
    a1 := 2 * pi + a1;
  if a1 > pi then
    result := true
  else
    result := false;
end;

function TGPoint.areCollinear(A, B: TGPoint): boolean;
begin
  result := ((B.y - A.y) * (x - A.x) - (B.x - A.x) * (y - A.y)) = 0;
end;

function TGPoint.Bisector(p: TGPoint): TGLine;
var
  A: TGLine;
  sx, sy, dx, dy: extended;
begin
  sx := (x + p.x) / 2;
  sy := (y + p.y) / 2;
  dx := p.x - x;
  dy := p.y - y;
  A := TGLine.Create(TGPoint.Create(sx - dy, sy + dx, nil, nil),
    TGPoint.Create(sx + dy, sy - dx, nil, nil), Vector, nil, GetCanvas);
  A.BisectorOf[1] := GetOrigIndex;
  A.BisectorOf[2] := p.GetOrigIndex;
  result := A;
end;

// Got this one from the internet
function TGPoint.CircleCenter(A, B: TGPoint): TGPoint;
var
  u, v, den: extended;
begin
  u := ((A.x - B.x) * (A.x + B.x) + (A.y - B.y) * (A.y + B.y)) / 2.0;
  v := ((B.x - x) * (B.x + x) + (B.y - y) * (B.y + y)) / 2.0;
  den := (A.x - B.x) * (B.y - y) - (B.x - x) * (A.y - B.y);
  result := TGPoint.Create((u * (B.y - y) - v * (A.y - B.y)) / den,
    (v * (A.x - B.x) - u * (B.x - x)) / den, nil, GetCanvas);

end;

end.
